home *** CD-ROM | disk | FTP | other *** search
/ The Best of MacTutor - S…e Code for Volumes 1 to 5 / The Best of MacTutor - Source Code for Volume 1-5 (Wayzata Technology)(6031)(1990).bin / Source Code / #11 (Aug 86) / forth / exp⁄ln next >
Text File  |  1986-06-03  |  5KB  |  227 lines
  1. ( 32 bit floating point routines, 27.4.1986 J. Langowski )
  2. only forth also assembler also sane
  3. include" add.sub"
  4. include" mul.sp"
  5. include" div.sp"
  6.  
  7. CODE 4*
  8.      MOVE.L (A6)+,D0
  9.      ASL.L  #2,D0
  10.      MOVE.L D0,-(A6)
  11.      RTS
  12. END-CODE MACH
  13.  
  14.  
  15. ( extract biased exponent & mantissa from 32 bit FP # )
  16.  
  17. CODE get.exp
  18.      MOVE.L  (A6)+,D0
  19.      MOVE.L  D0,D1
  20.      SWAP.W  D0
  21.      LSR.W   #7,D0
  22.      ANDI.L  #$FF,D0
  23.      MOVE.L  D0,-(A6)
  24.      ANDI.L  #$7FFFFF,D1
  25.      ORI.L   #$3F800000,D1
  26.      MOVE.L  D1,-(A6)
  27.      RTS
  28. END-CODE
  29.    
  30. CODE stoi  
  31.         MOVE.L  (A6)+,D0
  32.         MOVE.L  D0,D1
  33.         SWAP.W  D0
  34.         LSR.W   #7,D0
  35.         SUBI.B  #127,D0
  36.         BMI     @zero
  37.         BEQ     @one
  38.         ANDI.L  #$7FFFFF,D1
  39.         BSET    #23,D1
  40.         CMP.B   #8,D0
  41.         BCC     @long.shift
  42.         LSL.L   D0,D1
  43.         CLR.W   D1
  44.         SWAP.W  D1
  45.         LSR.L   #7,D1
  46.         MOVE.L  D1,-(A6)
  47.         RTS
  48. @long.shift
  49.         LSL.L   #7,D1
  50.         SUBQ.B  #7,D0
  51.         CLR.L   D2
  52. @shifts LSL.L   #1,D1
  53.         ROXL.L  #1,D2
  54.         SUBQ.B  #1,D0
  55.         BNE     @shifts
  56.         CLR.W   D1
  57.         SWAP.W  D1
  58.         LSR.L   #7,D1
  59.         LSL.L   #8,D2
  60.         ADD.L   D2,D2
  61.         OR.L    D2,D1
  62.         MOVE.L  D1,-(A6)
  63.         RTS
  64. @zero   CLR.L   D0
  65.         MOVE.L  D0,-(A6)
  66.         RTS
  67. @one    MOVEQ.L #1,D0
  68.         MOVE.L  D0,-(A6)
  69.         RTS
  70. END-CODE
  71.  
  72. : s>i dup 0< if stoi negate else stoi then ;
  73.  
  74. CODE itos
  75.         MOVE.L  (A6)+,D0
  76.         BEQ     @zero
  77.         CLR.L   D1
  78.         MOVE.L  #$7F,D2
  79. @shifts CMPI.L  #1,D0
  80.         BEQ     @one
  81.         LSR.L   #1,D0
  82.         ROXR.L  #1,D1
  83.         ADDQ.L  #1,D2
  84.         BRA     @shifts
  85. @one    LSR.L   #8,D1
  86.         LSR.L   #1,D1
  87.         SWAP.W  D2
  88.         LSL.L   #7,D2
  89.         BCLR    #31,D2
  90.         OR.L    D2,D1
  91.         MOVE.L  D1,-(A6)
  92.         RTS
  93. @zero   MOVE.L  D0,-(A6)
  94.         RTS
  95. END-CODE        
  96.  
  97. hex
  98. : i>s dup 0< if negate itos 80000000 or else itos then ;
  99. decimal
  100.  
  101. : s. s>f f. ;
  102.  
  103. ( vocabulary maths also maths definitions )
  104.  
  105. decimal
  106. fp 9 float
  107.  
  108. -inf f>s constant -infinity
  109.  inf f>s constant  infinity
  110.  
  111. 1.0  f>s constant one
  112. 10.  f>s constant ten
  113. 100. f>s constant hun
  114. pi f>s constant pi.s
  115. 2.718281828  f>s constant eu
  116.  
  117. ( exponential, natural log )
  118.  
  119.  .9999964239 f>s constant a1ln
  120. -.4998741238 f>s constant a2ln
  121.  .3317990258 f>s constant a3ln
  122. -.2407338084 f>s constant a4ln
  123.  .1676540711 f>s constant a5ln
  124. -.0953293897 f>s constant a6ln
  125.  .0360884937 f>s constant a7ln
  126. -.0064535442 f>s constant a8ln
  127.  
  128. variable ln2table 1020 vallot
  129.   2.0 fln    f>s constant ln2
  130.  
  131. : fill.ln2table
  132.     256 0 do ln2 i 127 - i>s s*
  133.              i 4* ln2table + !
  134.           loop
  135. ;
  136.  
  137. : ln.base 
  138.     one s- a8ln over s*
  139.            a7ln s+ over s*
  140.            a6ln s+ over s*
  141.            a5ln s+ over s*
  142.            a4ln s+ over s*
  143.            a3ln s+ over s*
  144.            a2ln s+ over s*
  145.            a1ln s+ s*
  146. ;
  147.  
  148. : ln dup 0> if get.exp
  149.                ln.base
  150.                swap 4* ln2table + @
  151.                s+
  152.             else drop -infinity
  153.             then
  154. ;
  155.  
  156. : lnacc
  157.   1000 0 do 
  158.     i . i i>s ln  dup s.
  159.         i i>f fln fdup f.
  160.           s>f f- f. cr
  161.     loop
  162. ;
  163.  
  164. variable exptable 700 vallot
  165.  
  166. : fill.exptable
  167.       176 0 do i 87 - i>f fe^x f>s
  168.              i 4* exptable + !
  169.           loop
  170. ;
  171.   
  172. -.9999999995 f>s constant a1exp
  173.  .4999999206 f>s constant a2exp
  174. -.1666653019 f>s constant a3exp
  175.  .0416573745 f>s constant a4exp
  176. -.0083013598 f>s constant a5exp
  177.  .0013298820 f>s constant a6exp
  178. -.0001413161 f>s constant a7exp
  179.  
  180. : exp.base a7exp over s*
  181.            a6exp s+ over s*
  182.            a5exp s+ over s*
  183.            a4exp s+ over s*
  184.            a3exp s+ over s*
  185.            a2exp s+ over s*
  186.            a1exp s+ s*
  187.            one s+
  188.            one swap s/
  189. ;
  190.  
  191. : exp dup s>i swap over i>s s- exp.base swap 
  192.           dup -87 < if 2drop 0
  193.      else dup  88 > if 2drop infinity
  194.      else 87 + 4* exptable + @ ( get exp of integer part ) s* then
  195.      then
  196. ;
  197.  
  198. : expacc
  199.   1000 0 do 
  200.     i . i i>s hun  s/  exp  dup s.
  201.         i i>f 100. f/ fe^x fdup f.
  202.           s>f f- f. cr
  203.     loop
  204. ;
  205.  
  206. :  emptyloop 0  1000 0 do  dup  drop loop  drop ;
  207. : femptyloop 0. 1000 0 do fdup fdrop loop fdrop ;
  208.  
  209. : testexp  ten one s+ 1000 0 do  dup  exp  drop loop  drop ;
  210. : testfexp        11. 1000 0 do fdup fe^x fdrop loop fdrop ;
  211.  
  212. : testln  ten one s+ 1000 0 do  dup  ln  drop loop  drop ;
  213. : testfln        11. 1000 0 do fdup fln fdrop loop fdrop ;
  214.  
  215. : speed.test cr
  216.     ." Testing 32 bit routines..." cr
  217.     ."    empty..." counter emptyloop timer cr
  218.     ."      exp..." counter testexp timer cr
  219.     ."       ln..." counter testln timer cr cr
  220.  
  221.     ." Testing SANE routines..." cr
  222.     ."    empty..." counter femptyloop timer cr
  223.     ."      exp..." counter testfexp timer cr
  224.     ."       ln..." counter testfln timer cr
  225. ;
  226.  
  227.